(* in AstO.Let non campare il tipo? *)

let name_of_closure n = Printf.sprintf "Closure_%d" n 
let name_of_apply n = Printf.sprintf "apply_%d" n

let next_fresh_id = ref 0
let next_fresh_cl = ref 0

let get_fresh_id () =
  let res = "t_" ^ (string_of_int !next_fresh_id) in
  incr next_fresh_id ;
  res

let get_fresh_cl name =
  let res = (String.capitalize name) ^ "_C_" ^ (string_of_int !next_fresh_cl) in
  incr next_fresh_cl;
  res

(*
let rec new_name prefix l= 
 let rec aux i =
  let name = (prefix ^ (string_of_int i)) in
    if (List.mem (Ast.Id name) (fst(List.split l))) then
    aux (i+1) else name in
  aux 0
*)

let rec remove_var fv =
  function
      [] -> fv
    | x::l -> remove_var (List.remove_assoc x fv) l  

let make_dec l =
  List.map (fun x -> ("Value",x)) l 

let free_vars bvars expr =
  let fvars = ref [] in
  let rec aux bvars =
    function
	Ast.Const _ -> ()
      | Ast.Id x when List.mem x bvars -> ()
      | Ast.Id x when List.mem x !fvars -> ()
      | Ast.Id x -> fvars := x :: !fvars
      | Ast.Apply (expr, exprs) ->
	  aux bvars expr;
	  List.iter (aux bvars) exprs
      | Ast.Op (_, exprs) -> List.iter (aux bvars) exprs
      | Ast.Let (bindings, expr) ->
	  List.iter (fun (_, expr) -> aux bvars expr) bindings;
	  aux (List.map fst bindings @ bvars) expr
      | Ast.If (expr1, expr2, expr3) ->
	  aux bvars expr1;
	  aux bvars expr2;
	  aux bvars expr3
      | Ast.Fun (args, expr) -> aux (args @ bvars) expr
      | Ast.LetRec (bindings, expr) ->
	  let bvars' = List.map fst bindings @ bvars in
	    List.iter (fun (_, expr) -> aux bvars' expr) bindings;
	    aux bvars' expr

  in
    aux bvars expr;
    !fvars

let compile name expr =
  let cl = ref [] in
  let add_class cls = cl := cls :: !cl in

  let rec compile_expr fv fun_name =
    function
	Ast.Const k -> AstO.Const k   
      | Ast.Id x when List.mem x fv -> AstO.Id x
      | Ast.Id x when x = fun_name -> AstO.Id "this"
      | Ast.Id x -> AstO.FieldAccess (AstO.Id "this", x)
      | Ast.Apply (expr, exprs) ->
	  AstO.MethodCall(
	    AstO.Cast ("Applicable", compile_expr fv fun_name expr),
	    name_of_apply (List.length exprs),
	    List.map (compile_expr fv fun_name) exprs
	  ) 
      | Ast.Op (op, exprs) -> AstO.StaticCall ("Prelude", op, List.map (compile_expr fv fun_name) exprs)
      | Ast.Let (bindings, expr) ->
	  let bindings' = List.map (fun (x, expr) -> (x, compile_expr fv fun_name expr)) bindings in
	    AstO.Let (bindings',
		      compile_expr (List.map fst bindings @ fv) fun_name expr)
      | Ast.If (expr1, expr2, expr3) -> AstO.If (compile_expr fv fun_name expr1,
						 compile_expr fv fun_name expr2,
						 compile_expr fv fun_name expr3)
      | Ast.Fun (param_list, expr) ->
	  let fvars = free_vars param_list expr in
	  let cls_name = compile_function fvars "" param_list expr in
	  let tmp = get_fresh_id () in
	    AstO.New ([tmp,
		       cls_name,
		       List.map (compile_expr fv fun_name) (List.map (fun x -> Ast.Id x) fvars)],
		      AstO.Id tmp)
      | Ast.LetRec (bindings, expr) ->
	  let fun_names = List.map fst bindings in
	  let bindings' = List.map (compile_let_rec fv fun_name fun_names) bindings in
	    AstO.New (bindings', compile_expr (fun_names @ fv) fun_name expr)
    

  and compile_let_rec fv fun_name fun_names (var, fun_expr) =
    match fun_expr with
	Ast.Fun (args, expr) ->
	  let fvars = free_vars (var :: args) expr in
	  let cls_name = compile_function fvars var args expr in
	    (var,
	     cls_name,
	     List.map (compile_expr fv fun_name) (List.map (fun x -> Ast.Id x) fvars))
      | _ -> assert false (* IMPOSSIBLE *)

  and compile_function fvars fun_name args expr =
    let cls_name = get_fresh_cl name in
      add_class (
	AstO.Class (cls_name,
		    name_of_closure (List.length args),
		    make_dec fvars,
		    [AstO.Method (
		       AstO.Instance, "Value",
		       name_of_apply (List.length args),
		       make_dec args,
		       Some (compile_expr args fun_name expr)
		     )]
		   )
      );
      cls_name
  in
  let expr' = compile_expr [] "" expr in
    (!cl, expr')
